Celestin Apprentice 4/Apprentice-Release4.iso/Languages/MacQForth 1.0/source/MacQForth Source/Monitor.mops

Text File | 1995-04-03 | 13.0 KB | 360 lines | [TEXT/ALFA]

\ Section: System Monitor

\
\ System monitor - $FFF0
\

\ alternate output words capture text in theText buffer

variable {len}  \ hold the address and length for {expect}
variable {addr}
variable {ptr}
variable ?cr

: {emit}  ( c -- ) rA ! $F3    ; \ emit a character through $F3
: {space} ( -- )   20 {emit}  ; \ output a space
: {cr}    ( -- )   ?scroll cr ; \ cr

: {expect} ( addr len -- ) \ get a line of text
  \ using $FB for 'key' and $F3 for 'emit'
   {len} !  {addr} !  0 {ptr} !  0 ?cr !
   begin
     {ptr} @  {len} @ <  \ while ptr<len and not ?cr
     ?cr @ not and
   while
     $FB \ key           \ read a key
     rA @ 8d <> if
       rA @ 88 <> if
         $F3 \ emit
         rA @ 7F and {addr} @ {ptr} @ + c!
         {ptr} @ 1+ {ptr} ! \ not cr or bs, output and put in buffer
       else
         <del   \ remove the character
         {ptr} @ 1- dup
         0< if drop 0 @xy swap drop E swap gotoxy then  \ bs
         {ptr} !
       then
     else
       0 {addr} @ {ptr} @ + c!   \ cr
       space                     \ remove '_'
       -1 ?cr ! {cr}
     then
   repeat
;

variable buff

variable mnemonics 'type ADC  mnemonics ! \ table of instruction names
'type AND  , 'type ASL  , 'type BCC  , 'type BCS  , 'type BEQ  ,
'type BIT  , 'type BMI  , 'type BNE  , 'type BPL  , 'type BRA  ,
'type BRK  , 'type BVC  , 'type BVS  , 'type CLC  , 'type CLD  ,
'type CLI  , 'type CLV  , 'type CMP  , 'type CPX  , 'type CPY  ,
'type DEA  , 'type DEC  , 'type DEX  , 'type DEY  , 'type EOR  ,
'type INA  , 'type INC  , 'type INX  , 'type INY  , 'type JMP  ,
'type JSR  , 'type LDA  , 'type LDX  , 'type LDY  , 'type LSR  ,
'type NOP  , 'type ORA  , 'type PHA  , 'type PHP  , 'type PHX  ,
'type PHY  , 'type PLA  , 'type PLP  , 'type PLX  , 'type PLY  ,
'type ROL  , 'type ROR  , 'type RTI  , 'type RTS  , 'type SBC  ,
'type SEC  , 'type SED  , 'type SEI  , 'type STA  , 'type STX  ,
'type STY  , 'type STZ  , 'type TAX  , 'type TAY  , 'type TRB  ,
'type TSB  , 'type TSX  , 'type TXA  , 'type TXS  , 'type TYA  ,
'type ???  ,

\ listing table, each entry is 4 bytes long <00><00><instruction#><mode>

\ <mode>=  00 - implied,    1 byte
\          01 - immediate,  2 byte
\          02 - absolute,   3 byte
\          03 - zero page,  2 byte
\          04 - ABS,rX,      3 byte
\          05 - ZPG,rX,      2 byte
\          06 - (IND,rX),    2 byte
\          07 - ABS(IND,rX), 3 byte
\          08 - (IND),rY,    2 byte
\          09 - (ZPG),      2 byte
\          0A - (ABS),      3 byte
\          0B - ABS,rY,      3 byte
\          0C - ZPG,rY,      2 byte


variable list  0C00 list !
2606 , 4300 , 4300 , 3E03 , 2603 , 0303 , 4300 , 2800 , 2601 , 0300 ,
4300 , 3E02 , 2602 , 0302 , 4300 ,        \ row 00

0A01 , 2608 , 2609 , 4300 , 3D03 , 2606 , 0306 , 4300 , 0F00 , 260B ,
1B00 , 4300 , 3D02 , 2604 , 0304 , 4300 , \ row 01

2002 , 0206 , 4300 , 4300 , 0703 , 0203 , 2F03 , 4300 , 2C00 , 0201 ,
2F00 , 4300 , 0702 , 0202 , 2F02 , 4300 , \ row 02

0801 , 0208 , 0209 , 4300 , 0705 , 0205 , 2F05 , 4300 , 3400 , 020B ,
1600 , 4300 , 0704 , 0204 , 2F04 , 4300 , \ row 03

3100 , 1A06 , 4300 , 4300 , 4300 , 1A03 , 2403 , 4300 , 2700 , 1A01 ,
2400 , 4300 , 1F02 , 1A02 , 2402 , 4300 , \ row 04

0D01 , 1A08 , 1A09 , 4300 , 4300 , 1A05 , 2405 , 4300 , 1100 , 1A0B ,
2A00 , 4300 , 4300 , 1A04 , 2404 , 4300 , \ row 05

3200 , 0106 , 4300 , 4300 , 3A03 , 0103 , 3003 , 4300 , 2B00 , 0101 ,
3000 , 4300 , 1F0A , 0102 , 3002 , 4300 , \ row 06

0E01 , 0106 , 0109 , 4300 , 3A05 , 0105 , 3005 , 4300 , 3600 , 010B ,
2E00 , 4300 , 1F07 , 0104 , 3004 , 4300 , \ row 07

0B01 , 3706 , 4300 , 4300 , 3903 , 3703 , 3803 , 4300 , 1900 , 0701 ,
4000 , 4300 , 3902 , 3702 , 3802 , 4300 , \ row 08

0401 , 3708 , 3709 , 4300 , 3905 , 3705 , 380C , 4300 , 4200 , 370B ,
4100 , 4300 , 3A02 , 3704 , 3A04 , 4300 , \ row 09

2301 , 2106 , 2201 , 4300 , 2303 , 2103 , 2203 , 4300 , 3C00 , 2101 ,
3B00 , 4300 , 2302 , 2102 , 2202 , 4300 , \ row 0A

0501 , 2108 , 2109 , 4300 , 2305 , 2105 , 220C , 4300 , 1200 , 210B ,
3F00 , 4300 , 2304 , 2104 , 220B , 4300 , \ row 0B

1501 , 1306 , 4300 , 4300 , 1503 , 1303 , 1703 , 4300 , 1E00 , 1301 ,
1800 , 4300 , 1502 , 1302 , 1702 , 4300 , \ row 0C

0901 , 1308 , 1309 , 4300 , 4300 , 1305 , 1705 , 4300 , 1000 , 130B ,
2900 , 4300 , 4300 , 1304 , 1704 , 4300 , \ row 0D

1401 , 3306 , 4300 , 4300 , 1403 , 3303 , 1C03 , 4300 , 1D00 , 3301 ,
2500 , 4300 , 1402 , 3302 , 1C02 , 4300 , \ row 0E

0601 , 3308 , 3309 , 4300 , 4300 , 3305 , 1C05 , 4300 , 3500 , 330B ,
2D00 , 4300 , 4300 , 3304 , 1C04 , 4300 , \ row 0F

: uppercase \ make a character uppercase
   dup dup 60 > swap 7B < and if 20 - then ;

: chrs ( buff maxlen -- length ) \ returns the length of the line
   0 do dup i + c@ 0= if drop i FF else 1 then +loop ;

variable buff2 4C allot \ temporary buffer
variable k  \ index
: killSpaces \ remove spaces from the input line
   0 k !
   buff @ 50 chrs 1+ 0 do
     buff @ i + c@ dup 20 <> if
       uppercase buff2 k @ + c!  \ save in temporary buffer
       k @ 1+ k !      \ increment k
     else drop then
   loop
   buff2 50 chrs 1+ 0 do
     buff2 i + c@  buff @ i + c!  \ put in original buffer
   loop ;

variable num 4C allot \ conversion buffer
variable endchar \ stop character
variable buffaddr \ buffer address
: getNumber ( addr end-char -- n ) \ make a string a number
   1 k ! \ use k defined above in killSpaces
   20 num c! \ initial blank
   endchar ! buffaddr ! \ save end character and buffer address
   begin
     buffaddr @ c@ endchar @ <>  \ haven't reached match character
   while
     buffaddr @ c@ uppercase
     num k @ + c!                \ copy character to num
     buffaddr @ 1+ buffaddr !     \ increment buffer pointer
     k @ 1+ k !                    \ and index pointer
   repeat
   20 num k @ + c!  \ add final blank
    0 num k @ 1+ + c! \ and null
   num k @ 1+ evaluate \ convert and leave on stack, Mops
   \ 0 0 num (number) drop drop \ Yerk
;

variable lines    \ number of lines listed
variable listAddr \ address
variable aLabel    \ holds a compressed label

: printLabel   \ print an instruction label
  1- 4* mnemonics + @ \ get the label
  aLabel !             \ save it
  aLabel c@ {emit} aLabel 1+ c@ {emit} aLabel 2+ c@ {emit} \ print it
  {space} ;

: instSize  \ return instruction size in bytes
    dup 0 = if drop 1 else \ implied
    dup 1 = if drop 2 else \ immediate
    dup 2 = if drop 3 else \ absolute
    dup 3 = if drop 2 else \ zero page
    dup 4 = if drop 3 else \ abs,x
    dup 5 = if drop 2 else \ zpg,x
    dup 6 = if drop 2 else \ ind,x
    dup 7 = if drop 3 else \ abs(ind,x)
    dup 8 = if drop 2 else \ (ind),y
    dup 9 = if drop 2 else \ (zpg)
    dup 0A = if drop 3 else \ (abs)
    dup 0B = if drop 3 else \ abs,y
        0C = if      2 else \ zpg,y
    1 then then then then then then then then then then then then then
;

: 1hex ( h -- ) \ print a single hex digit
   dup 9 > if 37 + {emit} else 30 + {emit} then ;

: 2hex  dup 10 / swap 10 mod swap 1hex 1hex ;
: 4hex  dup 100 / swap 100 mod swap 2hex 2hex ;

: .$ ( num size -- ) \ print num as a size hex number
   \ assumes size is either 2 or 4
   2 = if 2hex else 4hex then ;

: outHex ( size -- ) \ output hex data
   listAddr @ $@ 2 .$ {space}  \ all are at least one byte
   dup 1 = if drop {space} {space} {space}  {space} {space} else
   dup 2 = if  drop          \ two bytes
     listAddr @ 1+ $@ 2 .$
     {space} {space} {space}
   else
     3 = if                  \ three bytes
     listAddr @ 1+ $@ 2 .$ {space}
     listAddr @ 2+ $@ 2 .$
     then
   then then
   {space} ;

variable b1 \ first data byte
variable b2 \ second data byte

: .b @ 2 .$ ; \ print a data byte

: .imm 23 {emit} 24 {emit} b1 .b ;                               \ immediate
: .abs 24 {emit} b2 .b b1 .b   ;                                 \ absolute
: .zpg 24 {emit} b1 .b         ;                                 \ zero page
: .abx 24 {emit} b2 .b b1 .b 2C {emit} 58 {emit} ;               \ absolute,x
: .zpx 24 {emit} b1 .b 2C {emit} 58 {emit} ;                     \ zero page,x
: .zix 28 {emit} 24 {emit} b1 .b 2C {emit} 58 {emit} 29 {emit} ; \ ($33,rX)
: .aix 28 {emit} 24 {emit} b2 .b b1 .b 2C {emit} 58 {emit} 29 {emit} ; \ ($FDED,rX)
: .ziy 28 {emit} 24 {emit} b1 .b 29 {emit} 2C {emit} 59 {emit} ; \ ($33),rY
: .zpi 28 {emit} 24 {emit} b1 .b 29 {emit} ;                     \ ($33)
: .abi 28 {emit} 24 {emit} b2 .b b1 .b 29 {emit} ;               \ ($FDED)
: .aby 24 {emit} b2 .b b1 .b 2C {emit} 59 {emit} ;               \ $FDED,rY
: .zpy 24 {emit} b1 .b 2C {emit} 59 {emit} ;                     \ $33,rY

: printMode ( mode -- ) \ output instruction data
   listAddr @ 1+ $@ b1 !  listAddr @ 2+ $@ b2 ! \ save data bytes
   dup 0 = if drop      else \ implied
   dup 1 = if drop .imm else \ immediate
   dup 2 = if drop .abs else \ absolute
   dup 3 = if drop .zpg else \ zero page
   dup 4 = if drop .abx else \ absolute,x
   dup 5 = if drop .zpx else \ zero page,x
   dup 6 = if drop .zix else \ zero page indirect x
   dup 7 = if drop .aix else \ absolute indirect x
   dup 8 = if drop .ziy else \ zero page indirect y
   dup 9 = if drop .zpi else \ zero page indirect
   dup rA = if drop .abi else \ absolute indirect
   dup B = if drop .aby else \ absolute y
       C = if drop .zpy else \ zero page y
   then then then then then then then then then then then
   then then
;

: listMem                                       \ 'L' - list memory
   buff @ 1+ c@ 0 <> if
     buff @ 1+ 0 getNumber  listAddr !
   then
   0 lines !
   begin
     lines @ 16 <
   while
     listAddr @ 4 .$ 2D {emit} {space} \ print address
     listAddr @ $@ 4* list + 3+ c@      \ get mode
     instSize outHex                     \ print hex codes
     listAddr @ $@ 4* list + 2+ c@        \ get instruction
     printLabel                            \ print instruction mnemonic
     listAddr @ $@ 4* list + 3+ c@          \ get mode
     dup printMode {space} {cr}              \ print data
     instSize listAddr @ + listAddr !         \ next instruction
     lines @ 1+ lines !                        \ increment lines
   repeat
;

variable addr1 \ starting address
variable addr2 \ ending address
: dumpHex                                       \ 'rX' - examine range of memory
   buff @ 1+ 2E getNumber addr1 !     \ start
   buffAddr @ 1+ 0 getNumber addr2 ! \ end, buffaddr pts to '.' from above
   addr1 @ 4 .$ 2D {emit} {space}
   addr2 @ 1+ addr1 @ do
      i $@ 2 .$ {space}
      i addr1 @ - 1+ 8 mod 0= if
         {space} {cr}
         i 1+ 4 .$ 2D {emit} {space}
      then
   loop {space} {cr}
;

: altMem                                        \ 'rS' - change memory
   buff @ 1+ 0 getNumber addr1 ! \ starting address
   addr1 @ 4 .$ 2D {emit} {space} addr1 @ $@ 2 .$ {space}
   begin
     addr2 3 {expect}  \ get input
     addr2 c@ 21 <>  \ input not a '!'
   while
     addr2 c@ 0 <> if   \ not a return
       addr2 0 getNumber \ get number entered
       addr1 @ $!         \ save the new value
     then
     addr1 @ 1+ addr1 !     \ go to next byte
     addr1 @ 4 .$ 2D {emit} {space}
     addr1 @ $@ 2 .$ {space}
   repeat ;

: interpretLine  \ interpret the line in the input buffer
   buff @ c@ \ get first character
   dup 58 = if drop dumpHex 0 else \ 'rX' examine memory
   dup 4C = if drop listMem 0 else \ 'L' list memory
   dup 51 = if drop -1        else \ 'Q' quit
   dup 53 = if drop altMem  0 else \ 'rS' substitute memory
   dup  0 = if drop         0 else \ <cr>
       0 \ simply ignore it
   then then then then then
;

variable tempA \ hold the current accumulator value to be restored on exit

: $CF  \ a simple monitor program
   \
   \ monitor commands:
   \
   \  L<addr>   -  disassembled listing starting at address
   \  L         -  disassembled listing from last address+1
   \  Q         -  exit monitor and return to Forth
   \  rS<addr>   -  set memory starting at <addr>, ! exits
   \  rX<addr1>.<addr2> - hex dump from <addr1> to <addr2>
   \
   0 0200 rY @ + $!       \ set end-of-line marker, rY-reg holds line length
   killSpaces             \ remove the spaces
   interpretLine          \ interpret the line
   if #Z set else #Z unset then  \ set Z flag to quit
;

: $C3 popQF $0000 10018 + ! ; \ set startup word

: $B7  \ low-level decompiler, assumes address on the stack
   popQF  listAddr !
   begin
     listAddr @ 4 .$ 2D {emit} {space} \ print address
     listAddr @ $@ 4* list + 3+ c@      \ get mode
     instSize outHex                     \ print hex codes
     listAddr @ $@ 4* list + 2+ c@        \ get instruction
     printLabel                            \ print instruction mnemonic
     listAddr @ $@ 4* list + 3+ c@          \ get mode
     dup printMode {space} {cr}              \ print data
     instSize listAddr @ + listAddr !         \ next instruction
   listAddr @ $@ 60 = until

   \ output last 'RTS'
   listAddr @ 4 .$ 2D {emit} {space} \ print address
   listAddr @ $@ 4* list + 3+ c@      \ get mode
   instSize outHex                     \ print hex codes
   listAddr @ $@ 4* list + 2+ c@        \ get instruction
   printLabel                            \ print instruction mnemonic
   listAddr @ $@ 4* list + 3+ c@          \ get mode
   printMode {space} {cr}